home *** CD-ROM | disk | FTP | other *** search
/ Windows Expert / Windows Expert.iso / utility / uwserver.zip / uwserver.tar / misc / macmouse.el < prev    next >
Lisp/Scheme  |  1991-01-25  |  9KB  |  272 lines
  1. ;;;  macmouse.el (Version: 2.0)
  2.  
  3. ;;;  Copyright (C) Gregory S. Lauer (glauer@bbn), 1985. 
  4. ;;;    Please send suggestions and corrections to the above address.
  5. ;;;
  6. ;;;  This file contains macmouse, a GNU Emacs mouse package for UW.
  7.  
  8.  
  9. ;;
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but without any warranty.  No author or distributor
  12. ;; accepts responsibility to anyone for the consequences of using it
  13. ;; or for whether it serves any particular purpose or works at all,
  14. ;; unless he says so in writing.
  15.  
  16. ;; Everyone is granted permission to copy, modify and redistribute
  17. ;; GNU Emacs, but only under the conditions described in the
  18. ;; document "GNU Emacs copying permission notice".   An exact copy
  19. ;; of the document is supposed to have been given to you along with
  20. ;; GNU Emacs so that you can know how you may redistribute it all.
  21. ;; It should be in a file named COPYING.  Among other things, the
  22. ;; copyright notice and this notice must be preserved on all copies.
  23.  
  24.  
  25. ;;;  Original version for Gosling emacs by Chris Kent, Purdue University 1985.
  26. ;;;  Modified by Gregory Lauer, BBN, Novemeber 1985.
  27. ;
  28. ;
  29. ;
  30. ; Macmouse provides the following features:
  31. ;  Up or down mouse button in a window selects that window
  32. ;
  33. ;  A scroll bar/thumbing area for each window with the following features:
  34. ;       the mode lines are horizontal scroll bars
  35. ;           (running from rightmost column to under leftmost column)
  36. ;       the unused right window bar and the dividing lines between
  37. ;           windows are vertical scroll bars
  38. ;           (running from top of window THRU modeline
  39. ;   for vertical scroll bars:
  40. ;     click at line 1 does previous page
  41. ;    click at last line does next page
  42. ;     click anywhere else "thumbs" to the relative portion of the buffer.
  43. ;     shift-click at line 1 scrolls one line down
  44. ;     shift-click at last line scrolls one line up
  45. ;     shift-click elsewhere moves line to top of window
  46. ;     option-shift-click elsewhere moves line to bottom of window
  47. ;   for horizontal scroll bars:
  48. ;       click at column 1 does scroll right one window width
  49. ;       click at last column does scroll left one window width
  50. ;       click anywhere else moves to that "percent" of the buffer width
  51. ;       shift-click at column 1 scrolls one column right
  52. ;       shift-click at last column scrolls one column left
  53. ;       shift-click elsewhere moves column to right of window
  54. ;       option-shift-click elsewhere moves column to left of window
  55. ;
  56. ; There is also basic positioning and kill-buffer support:
  57. ;     click in a buffer moves dot there and selects that buffer
  58. ;     drag copies the dragged region to the kill buffer
  59. ;     shift-drag deletes the dragged region to the kill buffer
  60. ;
  61. ;   It is possible to use the scrolling and thumbing area to make the region
  62. ;   larger than a single screen; just click, scroll, release. Make sure
  63. ;   that the last scroll is just a down event; the up must be in the buffer.
  64. ;   The last mouse position is remembered for each different buffer (not
  65. ;   window), and thus you can start a drag in one buffer, select another,
  66. ;   go back to the first buffer, etc.
  67. ;
  68. ;     option-click yanks from the kill buffer
  69. ;     option-shift-click similarly yanks from a named buffer.
  70. ; 
  71.  
  72. (defconst mouse-max-x 95 "Maximum UW column returned on mouse click")
  73. (defconst mouse-max-y 95 "Maximum UW row returned on mouse click")
  74.  
  75. (make-variable-buffer-local 'mouse-last-x) ; x of last event
  76. (set-default 'mouse-last-x 0)
  77.  
  78. (make-variable-buffer-local 'mouse-last-y) ; y of last event
  79. (set-default 'mouse-last-y 0)
  80.  
  81. (make-variable-buffer-local 'mouse-last-b) ; buttons at last event
  82. (set-default 'mouse-last-b 0)
  83.  
  84. (make-variable-buffer-local 'mouse-last-dot) ; dot after last event
  85. (set-default 'mouse-last-dot 0)
  86.  
  87. (make-variable-buffer-local 'scrolling-p)
  88. (set-default 'scrolling-p nil)
  89.  
  90. (defun move-mac-cursor ()
  91.   (interactive)
  92.   (let (savest b x y up down lock shift option command)
  93.     (setq savest stack-trace-on-error)
  94.     (setq stack-trace-on-error nil)
  95.                     ; decode everything
  96.     (setq y (- (read-char) 32))
  97.     (setq x (- (read-char) 32))
  98.     (setq b (- (read-char) 32))
  99.     (setq command (< 0 (logand b 1)))    ; command key
  100.     (setq shift (< 0 (logand b 2)))    ; shift
  101.     (setq lock (< 0 (logand b 4)))    ; caps-lock
  102.     (setq option (< 0 (logand b 8)))    ; option
  103.     (setq down (< 0 (logand b 16)))    ; mouse down
  104.     (setq up (< 0 (logand b 32)))    ; mouse up
  105.     (condition-case ()
  106.     (progn
  107.       (select-window-containing-x-and-y x y) ; side-effect sets scrolling-p
  108.       (if scrolling-p
  109.           (mouse-scroll-region b x y)
  110.         (progn
  111.           (move-to-window-x-y x y)    ; move cursor to mouse-dot always
  112.           (if down (setq mouse-last-dot (dot)))
  113.           (mouse-edit-action))))
  114.       (error (message "Click not in selectable window")
  115.          (sit-for 1)
  116.          (message "")))
  117.     (setq stack-trace-on-error savest)
  118.     (if down
  119.     (progn 
  120.       (setq mouse-last-x x)
  121.       (setq mouse-last-y y)
  122.       (setq mouse-last-b b))
  123.       (progn 
  124.     (setq mouse-last-x 0)
  125.     (setq mouse-last-y 0)
  126.     (setq mouse-last-b 0)))))
  127.  
  128. (defun mouse-edit-action ()
  129.                                 ;marking and editing actions on buttons:
  130.                 ;   if no movement, nothing.
  131.                 ;   if movement, save mouse-last-dot,
  132.                 ;      and edit.
  133.                 ; editing (on upstrokes):
  134.                 ;   unmodified, copy to kill buffer.
  135.                 ;   SHIFTed, delete (cut) to kill buffer.
  136.                 ; 
  137.                 ; option-click yanks from kill buffer; 
  138.                 ; shift-option-click from named buffer.
  139.   (let ((fun (get 'mouse-function b)))
  140.     (if fun (apply fun nil))))
  141.  
  142.  
  143.     ; individual button bindings
  144.     ; generally will only need up mouse button: mouse-last-dot
  145.     ; is saved automatically on down mouse button
  146.  
  147. ; only need to define functions for keys that get used
  148.  
  149. (put 'mouse-function 32            ; up
  150.      '(lambda ()
  151.          (if (and (not (mouse-click-p))
  152.          (not scrolling-p))
  153.         (copy-region-as-kill (dot) mouse-last-dot))))
  154.  
  155. (put 'mouse-function 34            ; up/shift
  156.      '(lambda ()
  157.          (if (and (not (mouse-click-p))
  158.          (not scrolling-p))
  159.            (kill-region (dot) mouse-last-dot))))
  160.  
  161. (put 'mouse-function 40            ; up/option
  162.      '(lambda ()
  163.          (if (mouse-click-p)
  164.         (progn
  165.           (yank)
  166.           (exchange-dot-and-mark)))))
  167.  
  168. (put 'mouse-function 42
  169.      '(lambda ()        ; up/option/shift
  170.     (if (mouse-click-p)
  171.         (insert-buffer (read-buffer "Insert contents of buffer: ")))))
  172.  
  173. (defun mouse-click-p ()
  174.   (= (dot) mouse-last-dot))
  175.  
  176. (defun set-window-boundaries ()
  177.   (let ((edges (window-edges)))
  178.     (setq xl (1+ (car edges)))
  179.     (setq yt (1+ (car (cdr edges))))
  180.     (let ((temp (car (cdr (cdr edges)))))
  181.       (setq xr (if (= (screen-width) temp) mouse-max-x temp)))
  182.     (let ((temp (car (cdr (cdr (cdr edges))))))
  183.       (setq yb (if (= (screen-height) temp) mouse-max-y temp )))))
  184.  
  185. (defun select-window-containing-x-and-y (x y)
  186.   (let ((starting-window (selected-window)))
  187.     (set-window-boundaries)
  188.     (while (not (point-in-window x y))
  189.       (other-window 1)
  190.       (if (eq (selected-window) starting-window)
  191.       (error nil)
  192.     (set-window-boundaries)))
  193.     (if (or (= x xr) (= y yb))
  194.     (setq scrolling-p t)
  195.       (setq scrolling-p nil))))
  196.  
  197. (defun point-in-window (x y)
  198.   (and (<= xl x)(<= x xr)(<= yt y)(<= y yb)))
  199.  
  200. (defun move-to-window-x-y (x y)
  201.   (move-to-window-line (- y yt))
  202.   (move-to-window-column (- x xl)))
  203.  
  204. (defun move-to-window-column (x)
  205.   (move-to-column (+ (max 0 (- (window-hscroll) 1)) x)))
  206.  
  207. (defun mouse-scroll-region (b x y)
  208.   (if down
  209.       (if shift
  210.       (do-lines b x y)
  211.     (do-pages b x y)))
  212.   (if (and up
  213.        (or (/= x mouse-last-x)
  214.            (/= y mouse-last-y)))
  215.       (if shift
  216.       (do-lines b x y)
  217.     (do-pages b x y))))
  218.  
  219. (defun do-lines (b x y)            ; fine control over lines
  220.   (if (= x xr)
  221.       (cond ((= y yt)(scroll-down 1))
  222.         ((= y yb)(scroll-up 1))
  223.         (t (if option
  224.            (scroll-down (- yb y 1))
  225.          (scroll-up (- y yt))))))
  226.   (if (and (= y yb) (/= x xr))
  227.       (cond ((<= x xl)(scroll-right 1))
  228.         ((>= x (1- xr))(scroll-left 1))
  229.         (t (if option
  230.            (move-column-right x)
  231.          (move-column-left x))))))
  232.  
  233. (defun move-column-left (x)        ;need to mess about a bit because
  234.   (scroll-left                ;first scroll left of 1 just writes
  235.    (if (= (window-hscroll) 0)        ;a column of $s in column 1
  236.        (- x xl)
  237.      (- x xl 1))))
  238.  
  239. (defun move-column-right (x)
  240.   (scroll-right (- xr x 2)))
  241.  
  242.  
  243. (defun do-pages (b x y)            ; large motions via pages and thumbing
  244.   (if (= x xr)
  245.       (cond ((= y yt)(scroll-down nil))
  246.         ((= y yb)(scroll-up nil))
  247.         (t (goto-percent (/ (* (- y yt 1) 100)
  248.                 (- yb yt 2))))))
  249.   (if (and (= y yb)(/= x xr))
  250.       (cond ((<= x xl)(scroll-right (- (window-width)
  251.                        next-screen-context-lines)))
  252.         ((>= x (1- xr))(scroll-left (- (window-width)
  253.                        next-screen-context-lines)))
  254.         (t (goto-horizontal-percent (/ (* (- x xl 1) 100)
  255.                        (- xr xl 2)))))))
  256.  
  257. (defun goto-percent (p)
  258.   (goto-char (/ (* (- (dot-max) (dot-min)) p) 100)))
  259.  
  260. (defun goto-horizontal-percent (p)    ;try to put this percent of columns
  261.   (let ((window-offset (window-hscroll));in the center column of the window
  262.     delta)                ;unless that would move the first or
  263.     (setq delta                ;last column past the window edge
  264.       (- window-offset
  265.          (min (max 0 (- (/ (* (screen-width) p) 100)
  266.                 (/ (- xr xl) 2)))
  267.           (- (screen-width) (- xr xl)))))
  268.     (scroll-right delta)))
  269.  
  270.     
  271. (global-set-key "\em" 'move-mac-cursor)
  272.